COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	   MACAID 						  -*-LISP-*-
C00008 00003
C00011 00004
C00015 ENDMK
C⊗;
;;;   MACAID 						  -*-LISP-*-
;;;   **************************************************************
;;;   ***** MACLISP ******* MACRO DEFINITION AIDS  *****************
;;;   **************************************************************
;;;   ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;;   **************************************************************

;;; Current contents:
;;;   Functs:  FLATTEN-SYMS,  |carcdrp/||,  |no-funp/||, |side-effectsp/|| 
;;;	       +INTERNAL-DUP-P
;;;   Macros:  HERALD,  DEFSIMPLEMAC,  |constant-p/||



(eval-when (eval compile)
	   (cond ((status nofeature maclisp))
		 ((status macro /#))
		 ((getl '+INTERNAL-/#-MACRO '(SUBR AUTOLOAD))
		  (setsyntax '/# 'SPLICING '+INTERNAL-/#-MACRO))
		 ((fasload (LISP) SHARPM)))
)


; This is another of those losing files that need themselves loaded in 
;   order to be able to be compiled.
(eval-when (compile)
 (and (status nofeature macaid) 	(load '((LISP) MACAID)))
)

(defmacro HERALD (package-name &optional (version-number '||))
   (let* ((file (cond ((filep infile) 
		       (caddr (truename infile)))))
	  (v 	(cond ((and file (fixp (car (errset (readlist (exploden file)) () )))) 
		          file)
		      ('t version-number))) )
	 `(PROG2 (COND ((STATUS NOFEATURE NOLDMSG)
			(TERPRI MSGFILES)
			(PRINC '|;Loading | MSGFILES)
			(PRINC ',package-name MSGFILES)
			(PRINC '| | MSGFILES)
			(PRINC ',v MSGFILES)
			(PRINC '| | MSGFILES)))
		 (DEFPROP ,package-name ,v VERSION))))

(herald MACAID /60)

(declare (special |carcdrp/||) (*expr |carcdrp/||))

;;; Many functions of one argument can be macro-expanded, providing
;;; 	that the argument-form can be multiplied.  If not, then we must
;;;	wrap a LAMBDA around it, and give it an argument-form of a symbol.

(defmacro DEFSIMPLEMAC (oname vars /&rest body &aux var name)
    (and (or (atom vars) (not (symbolp (car vars))) (cdr vars))
	 (error '|Bad arglist for DEFSIMPLEMAC| `(,oname ,vars ,@body)))
    (setq var (car vars)
	  name (cond ((eq (typep oname) 'LIST) (car oname)) (oname)))
    `(DEFMACRO ,oname ,vars
	       (SETQ ,VAR (MACROEXPAND ,VAR))
	       (COND ((|no-funp/|| ,VAR)
		      ,(cond ((cdr body) '(cons 'PROGN body))
			     ((car body))))
		     ((EQ (CAR ,VAR) 'PROG2)
		      `(PROG2 ,(cadr ,VAR) 
			      (,',name ,(caddr ,VAR))
			      ,. (cdddr ,VAR)))
		     ((EQ (CAR ,VAR) 'SETQ)
		      `(PROG2 ,,VAR (,',name ,(cadr ,VAR))))
		     ((LET ((G (GENSYM)))
			   `((LAMBDA (,g) (,',name ,g)) ,,VAR))))))

(defsimplemac |constant-p/|| (X) 
	  `(CASEQ (TYPEP ,x)
		  (SYMBOL ())
		  (LIST (MEMQ (CAR ,x) '(QUOTE FUNCTION)))
		  (T T)))

;  +INTERNAL-CARCDRP returns a -1 if arg is not a carcdr symbol, else returns
;    a 13.-bit number encoding the three things of the old carcdr property.

(defun |carcdrp/|| (x) 
  (cond ((get x 'CARCDR))
	(|carcdrp/||				;|carcdrp/|| is non-null iff  
	 (let ((n (+INTERNAL-CARCDRP x)))	; +INTERNAL-CARCDRP exists
	   (declare (fixnum n nn))
	   (cond ((< n 0) () )
		 ((putprop x 		;"cache" result on plist
		     (list* (cond ((< n 1←12.) 'A) ('D))
			    (implode 
			     `(C ,.(nconc 
				    (do ((z ()
					    (cons (cond ((zerop (boole 1 nn 1))
							 'A) 
							('D))
						  z))
					 (nn (boole 1 (lsh n -6) 63.)
					     (lsh nn -1)))
					((< nn 2) z))
				    '(R)))) 
			    (boole 1 n 63.))
		     'CARCDR)))))))

(comment FLATTEN-SYMS |no-funp/|| |side-effectsp/||)

(defun FLATTEN-SYMS (x l)
   (cond ((atom x)
	  (cond ((null x) l)
		((symbolp x) (cond ((memq x l) l) ((cons x l))))
		(l)))
	 ('t (FLATTEN-SYMS (car x) (FLATTEN-SYMS (cdr x) l)))))

(defun |no-funp/|| (x)
  (cond ((or (atom x) (memq (car x) '(QUOTE FUNCTION DECLARE))))
	((not (symbolp (car x)))  () )
	((|carcdrp/|| (car x)) (|no-funp/|| (cadr x)))
	((eq 'CXR (car x))  
	 (and (|no-funp/|| (cadr x)) (|no-funp/|| (caddr x))))
	((memq (car x) '(+ - * // \ 1+ 1- +$ -$ *$ //$ 1+$ 1-$))
	 (do ((y (cdr x) (cdr y)))
	     ((null y) t)
	   (cond ((|constant-p/|| (car y)))
		 (t (return ())))))))

;;; Non-null if it is "cheaper" to do a lambda-binding rather
;;;   than duplicating the permissibly-duplicatable code.
(defun +INTERNAL-DUP-P (x)
  (cond ((or (atom x) (memq (car x) '(QUOTE FUNCTION DECLARE))))
	((not (symbolp (car x)))  () )
	((memq (car x) '(CAR CDR CAAR CADR CDAR CDDR))
	 (or (atom (cadr x))
	     (|constant-p/|| (cadr x))))
	((eq 'CXR (car x))  
	 (and (|constant-p/|| (cadr x))
	      (or (atom (caddr x)) (|constant-p/|| (caddr x)))))
	((memq (car x) '(+ - * // \ 1+ 1- +$ -$ *$ //$ 1+$ 1-$))
	 (do ((y (cdr x) (cdr y)))
	     ((null y) t)
	   (cond ((|constant-p/|| (car y)))
		 (t (return ())))))))

(defun |side-effectsp/|| (x)
  (cond ((atom x) () )
	((memq (car x) '(QUOTE FUNCTION DECLARE)) () )
	((and (eq (typep (car x)) 'LIST) (eq (caar x) 'LAMBDA))
	 (or (mapcan '|side-effectsp/|| (cddar x))
	     (mapcan '|side-effectsp/|| (cdr x))))
	((or (not (symbolp (car x))) (get (car x) 'FSUBR)) (list 'T))
	((|carcdrp/|| (car x)) (|side-effectsp/|| (cadr x))) 
	((get (car x) '|side-effectsp/||) (mapcan '|side-effectsp/|| (cdr x)))
	((let ((nx (macroexpand-1* x)))
	      (cond ((null nx) (list 'T))
		    ((|side-effectsp/|| (car nx))))))))


(comment CARCDR and |side-effectsp/|| properties)

(and (not (boundp '|carcdrp/||))
     (not (setq |carcdrp/|| (get '+INTERNAL-CARCDRP 'SUBR)))
     (progn 	(DEFPROP CAR (A NIL . 6.) CARCDR)
		(DEFPROP CAAR (A CAR . 5.) CARCDR)
		(DEFPROP CAAAR (A CAAR . 19.) CARCDR)
		(DEFPROP CAAAAR (A CAAAR . 27.) CARCDR)
		(DEFPROP CAAADR (A CAADR . 26.) CARCDR)
		(DEFPROP CAADR (A CADR . 18.) CARCDR)
		(DEFPROP CAADAR (A CADAR . 17.) CARCDR)
		(DEFPROP CAADDR (A CADDR . 16.) CARCDR)
		(DEFPROP CADR (A CDR . 4.) CARCDR)
		(DEFPROP CADAR (A CDAR . 3.) CARCDR)
		(DEFPROP CADAAR (A CDAAR . 36.) CARCDR)
		(DEFPROP CADADR (A CDADR . 35.) CARCDR)
		(DEFPROP CADDR (A CDDR . 2.) CARCDR)
		(DEFPROP CADDAR (A CDDAR . 1.) CARCDR)
		(DEFPROP CADDDR (A CDDDR . 0.) CARCDR)
		(DEFPROP CDR (D NIL . 14.) CARCDR) 
		(DEFPROP CDAR (D CAR . 13.) CARCDR) 
		(DEFPROP CDAAR (D CAAR . 24.) CARCDR) 
		(DEFPROP CDAAAR (D CAAAR . 33.) CARCDR) 
		(DEFPROP CDAADR (D CAADR . 32.) CARCDR) 
		(DEFPROP CDADR (D CADR . 23.) CARCDR) 
		(DEFPROP CDADAR (D CADAR . 22.) CARCDR) 
		(DEFPROP CDADDR (D CADDR . 21.) CARCDR) 
		(DEFPROP CDDR (D CDR . 12.) CARCDR) 
		(DEFPROP CDDAR (D CDAR . 11.) CARCDR) 
		(DEFPROP CDDAAR (D CDAAR . 30.) CARCDR) 
		(DEFPROP CDDADR (D CDADR . 29.) CARCDR) 
		(DEFPROP CDDDR (D CDDR . 10.) CARCDR) 
		(DEFPROP CDDDAR (D CDDAR . 9.) CARCDR) 
		(DEFPROP CDDDDR (D CDDDR . 8.) CARCDR) 
		))

(mapc '(lambda (x) (putprop x 't '|side-effectsp/||))
      '(CONS NCONS XCONS ASSQ ASSOC COPYSYMBOL GET GETL 
	     GETCHAR GETCHARN IMPLODE LAST LIST LISTIFY PNGET 
	     EXPLODE EXPLODEC EXPLODEN FLATC FLATSIZE INTERN 
	     HUNK LISTARRAY MAKHUNK MAKNAM PLIST CXR 
	     MEMQ MEMBER SUBLIS SUBST REVERSE APPEND 
	     BIGP EQUAL EQ FIXP FLOATP NUMBERP SYMBOLP TYPEP
	     NOT NULL ODDP GREATERP LESSP PLUSP MINUSP ZEROP 
	     FILEP FASLP PROBEF NAMELIST NAMESTRING TRUENAME  
	PLUS DIFFERENCE TIMES QUOTIENT ADD1 SUB1 ABS 
	     + - * // 1+ 1- ↑ +$ -$ *$ //$ 1+$ 1-$ ↑$ 
	     \ \\  REMAINDER GCD EXP EXPT BOOLE > <  =
	     IFIX FIX LOG SQRT SIN COS ROT LSH FSC 
	     HAIPART HAULONG HUNKSIZE LENGTH SXHASH 
	ELT VREF VECTORP VECTOR MAKE-VECTOR VECTOR-LENGTH 
	    >= <= <$ <=$ =$ >=$ >$ 
	    *:CHARACTER-TO-FIXNUM  *:FIXNUM-TO-CHARACTER
	    FIXNUMP LIST-LENGTH CHARACTERP 
	    GET-PNAME STRING-APPEND STRINGP STRING-LENGTH 
	))


(sstatus feature MACAID)